home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacTech 1 to 12
/
MacTech-vol-1-12.toast
/
Tools
/
Alpha 6.51b13 ƒ
/
Tcl
/
SystemCode
/
library.tcl
< prev
next >
Wrap
Text File
|
1997-03-26
|
5KB
|
189 lines
# init.tcl --
#
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
# $Header: /rel/cvsfiles/devo/tcl/library/init.tcl,v 1.2 1992/12/23 15:39:29 zoo Exp $ SPRITE (Berkeley)
#
# Copyright 1991-1992 Regents of the University of California
# Permission to use, copy, modify, and distribute this
# software and its documentation for any purpose and without
# fee is hereby granted, provided that this copyright
# notice appears in all copies. The University of California
# makes no representations about the suitability of this
# software for any purpose. It is provided "as is" without
# express or implied warranty.
#
# unknown:
# Invoked when a Tcl command is invoked that doesn't exist in the
# interpreter:
#
# 1. See if the autoload facility can locate the command in a
# Tcl script file. If so, load it and execute it.
# 2. See if the command exists as an executable UNIX program.
# If so, "exec" the command.
# 3. If the command was invoked at top-level:
# (a) see if the command requests csh-like history substitution
# in one of the common forms !!, !<number>, or ^old^new. If
# so, emulate csh's history substitution.
# (b) see if the command is a unique abbreviation for another
# command. If so, invoke the command.
proc unknown args {
global auto_noload env unknown_pending;
set name [lindex $args 0]
if {[string length [set f [findCmd $name]]]} {
uplevel #0 source [list $f]
return [uplevel $args]
} else {
error "No such function: $name"
}
}
# auto_mkindex:
# Regenerate a tclIndex file from Tcl source files. Takes two arguments:
# the name of the directory in which the tclIndex file is to be placed,
# and a glob pattern to use in that directory to locate all of the relevant
# files.
proc auto_mkindex {dir files} {
global alphaLite
set oldDir [pwd]
cd $dir
append line "# Tcl autoload index file: each line identifies a file (nowrap)\n\n"
append line "set [file tail [string trim [pwd] :]]_index \{\n"
set cid [scancontext create]
scanmatch $cid {^proc[ ]} {
if {[regexp {^proc[ ]+([^ ]*)} $matchInfo(line) match procName]} {
append line "$procName "
}
}
foreach file [glob $files] {
if {($file == "menusLite.tcl") && !$alphaLite} continue;
watchCursor
set f ""
append line "\{[file tail $file] "
message [file tail $file]
set fid [open $file]
scanfile $cid $fid
close $fid
append line "\}\n"
}
scancontext delete $cid
append line "\}\n"
set f [open tclIndexx w]
puts $f $line nonewline
close $f
cd $oldDir
foreach i [info vars {*_index}] {
global $i
unset $i
}
}
proc findCmd cmd {
global global auto_path
foreach path $auto_path {
if {![file exists $path]} continue
set index "[file tail $path]_index"
global $index
if {![info exists $index]} {
uplevel #0 source [list "$path:tclIndexx"]
}
if {[regexp "\{(\\w+.tcl)\[^\}\]* [quoteExpr $cmd] " [set $index] dummy file]} {
return "$path:$file"
}
}
}
#================================================================================
# Wonderful procs from Vince Darley (vince@das.harvard.edu).
#===============================================================================
proc traceTclProc {} {
global tclMenu
if {[llength [traceFunc status]]>2} {
catch {markMenuItem $tclMenu {traceTclProc…} off}
catch {enableMenuItem $tclMenu dumpTraces off}
if {[string length [set data [traceDump]]]} {
if {[askyesno "Dump traces?"] == "yes"} {
dumpTraces [string trimright [lindex [traceFunc status] 3] {,}] $data
setWinInfo dirty 0
}
}
traceFunc off
message "Tracing off."
return
}
if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
set func [listpick -L $sel -p {Func Name:} [lsort -ignore [info procs]]]
} else {
set func [listpick -p {Func Name:} [lsort -ignore [info procs]]]
}
if {![string length $func]} return
traceFunc on $func ""
catch {markMenuItem $tclMenu {traceTclProc…} on}
catch {enableMenuItem $tclMenu dumpTraces on}
message "Tracing '$func'…"
}
proc dumpTraces {{name ""} {data ""}} {
if {![string length $name]} {
set name [string trimright [lindex [traceFunc status] 3] {,}]
}
if {![string length $data]} {
set data [traceDump]
}
if {![string length $data]} {
message "Trace buffer empty"
} else {
regsub -all {:} $name {.} name
new -n "* Trace '$name' *"
insertText $data
setWinInfo dirty 0
goto 0
}
}
proc rebuildTclIndices {} {
global auto_path
set d [pwd]
# do we really need the next line? Alpha's original uses it.
cd
foreach dir $auto_path {
# if directory exists
if { ![catch { cd $dir } ] } {
# if there are any files
if { ![catch { glob *.*tcl } ] } {
message "Building [file tail $dir] index…"
# if the '[incr tcl]' version exists, use that
# use 'catch' also in case directory is write-protected
if [catch { itcl_mkindex : *.*tcl } ] {
# else try the normal one
catch { auto_mkindex : *.*tcl }
}
}
}
}
# redo the auto-mode-file connections (see "smarterSource.tcl")
message "Building the mode-file dependency array"
catch {autoModeFiles}
message ""
cd $d
}